unit udmsrv;

{$mode ObjFPC}{$H+}

interface

uses
  Classes,
  SysUtils,
  Menus,
  Forms,
  ExtCtrls,
  Controls,
  Uni,
  rtcInfo,
  rtcSystem,
  rtcConn,
  rtcHttpSrv,
  rtcSrvModule,
  rtcCliModule,
  rtcFunction,
  rtcScript,
  rtcDataSrv,
  UniqueInstance;

type

  { Tdmsrv }

  Tdmsrv = class(TDataModule)
    fnDbQry  : TRtcFunction;
    fnDbSql  : TRtcFunction;
    fnDbValue  : TRtcFunction;
    fnDbID  : TRtcFunction;
    fnSysValue  : TRtcFunction;
    fnSysLogin  : TRtcFunction;
    fnSysLogout  : TRtcFunction;
    fnSysUpload  : TRtcFunction;
    fnSysDownload  : TRtcFunction;
    il16  : TImageList;
    mi11  : TMenuItem;
    mi12  : TMenuItem;
    mi99  : TMenuItem;
    fnSysLog  : TRtcFunction;
    Separator1  : TMenuItem;
    pmSystem  : TPopupMenu;
    rtcDp  : TRtcDataProvider;
    rtcfg  : TRtcFunctionGroup;
    rtchs  : TRtcHttpServer;
    rtcSe  : TRtcScriptEngine;
    rtcSm  : TRtcServerModule;
    ti  : TTrayIcon;
    ui  : TUniqueInstance;
    con  : TUniConnection;
    procedure DataModuleCreate(Sender  : TObject);
    procedure DataModuleDestroy(Sender  : TObject);
    procedure fnSysLogExecute(Sender  : TRtcConnection; Param  : TRtcFunctionInfo;
      Result  : TRtcValue);
    procedure fnSysValueExecute(Sender  : TRtcConnection;
      Param  : TRtcFunctionInfo; Result  : TRtcValue);
    procedure mi99Click(Sender  : TObject);
    procedure rtcDpCheckRequest(Sender  : TRtcConnection);
    procedure rtcDpDataReceived(Sender  : TRtcConnection);
    procedure rtchsDataIn(Sender  : TRtcConnection);
    procedure rtchsDataOut(Sender  : TRtcConnection);
    procedure tiDblClick(Sender  : TObject);
  private

  public

  end;

var
  dmsrv  : Tdmsrv;
  gPath  : string;
  gConfig  : TStrings;
  gDataIn, gDataOut  : int64;

procedure doLog(const aMsg  : string);
function sysPath(const aFile  : string): string;
function sysUrl(const aFile  : string): string;
function dbQry(const aSql  : string; const aParams  : array of variant): tuniquery;
function dbValue(const aSql  : string; const aParams  : array of variant): variant;
procedure dbQryFree(qry  : tuniquery);

implementation

{$R *.lfm}

{ Tdmsrv }
uses
  rtclog,
  ufrmmain;

function sysPath(const aFile  : string): string;
begin
  Result := (gpath + afile).replace('/', '\', [rfReplaceAll]).replace(
    '\\', '\', [rfReplaceAll]);
  {$ifdef LINUX}
  Result:=Result.replace('\','/',[rfReplaceAll]);
  {$endif}
end;

function sysUrl(const aFile  : string): string;
begin
  Result := aFile.replace(gpath, '', [rfreplaceall]).replace('\', '/', [rfReplaceAll]);
end;

function dbQry(const aSql  : string; const aParams  : array of variant): tuniquery;
var
  i  : integer;
begin
  Result := tuniquery.Create(nil);
  with Result, dmsrv, con do
  begin
    connection := con;
    if pooling then
      connection.connect;
    sql.Text := asql;
    for i := 0 to high(aparams) do
      params.items[i].Value := aparams[i];
  end;
end;

function dbValue(const aSql  : string; const aParams  : array of variant): variant;
var
  qry  : tuniquery;
begin
  qry := dbqry(aSql, aParams);
  with qry do
  begin
    Open;
    if findfirst then
      Result := fields.Fields[0].Value;
  end;
  dbqryfree(qry);
end;

procedure dbQryFree(qry  : tuniquery);
begin
  with qry do
  begin
    if connection.pooling then
      connection.disconnect;
    Free;
  end;
end;

procedure doLog(const aMsg  : string);
begin
  if frmmain <> nil then
    frmmain.mmolog.Lines.add(format('%s %s',
      [formatdatetime('hh:nn:ss.zzz', now), amsg]));
  xlog(amsg);
end;

procedure Tdmsrv.tiDblClick(Sender  : TObject);
begin
  if frmmain.showing then
    frmmain.hide
  else
    frmmain.Show;
end;

procedure Tdmsrv.DataModuleCreate(Sender  : TObject);
begin
  dolog('-----------------------------');
  dolog('启动服务器');
  rtchs.listen;
end;

procedure Tdmsrv.DataModuleDestroy(Sender  : TObject);
begin
  rtchs.stoplistennow;
  dolog('停止服务器');
end;

procedure Tdmsrv.fnSysLogExecute(Sender  : TRtcConnection;
  Param  : TRtcFunctionInfo; Result  : TRtcValue);
begin
  dolog(param.AsString['PARAMS']);
end;

procedure Tdmsrv.fnSysValueExecute(Sender  : TRtcConnection;
  Param  : TRtcFunctionInfo; Result  : TRtcValue);
begin
  Result.AsString := gconfig.values[param.AsString['PARAMS']];
end;

procedure Tdmsrv.mi99Click(Sender  : TObject);
begin
  case tmenuitem(Sender).tag of
    99  : application.Terminate;
  end;
end;

procedure Tdmsrv.rtcDpCheckRequest(Sender  : TRtcConnection);
begin
  with Sender, request do
    if (filename = '/ws') and WSUpgrade then
    begin
      accept;
      Response.WSUpgrade := True;
      Write;
    end
    else
      accept;
end;

procedure Tdmsrv.rtcDpDataReceived(Sender  : TRtcConnection);
var
  aFile  : string;
begin
  with Sender, request, rtcse do
    if filename = '/' then
      Write(formatdatetime('yyyy-mm-dd hh:nn:ss.zzz', now))
    else if leftstr(filename, 5) = '/web/' then
    begin
      response.contenttype := gconfig.values[extractfileext(filename)];
      try
        if gconfig.values['LogFile'] = '-1' then
          dolog(filename);
        aFile := sysPath(filename);
        aFile := read_file(aFile);
        aFile := Execute(rtchs, Compile(aFile)).astext;
        Write(aFile);
      except
        on e  : Exception do
          dolog(e.message);
      end;
    end;
end;

procedure Tdmsrv.rtchsDataIn(Sender  : TRtcConnection);
begin
  if gconfig.values['LogDataIO'] = '-1' then
    if not Sender.inMainThread then
      Sender.Sync(@rtchsDataIn)
    else
      gdatain := gdatain + Sender.DataIn;
end;

procedure Tdmsrv.rtchsDataOut(Sender  : TRtcConnection);
begin
  if gconfig.values['LogDataIO'] = '-1' then
    if not Sender.inMainThread then
      Sender.Sync(@rtchsDataOut)
    else
      gdataout := gdataout + Sender.Dataout;
end;

initialization
  startlog;
  gPath := extractfilepath(ParamStr(0));
  gConfig := TStringList.Create();
  if fileexists('config.dat') then
    gconfig.loadfromfile('config.dat');

finalization
  gconfig.Free;
  stoplog;
end.
